;;; -*- Mode:LISP; Package:NLISP; Readtable:CL; Base:10 -*-
;;;
;;; PRINT.LISP
;;;
;;; Still needs work: Flonums.  (no, really?)


(defvar *print-escape* T
  "Indicates whether or not to output escape characters when printing an
expression.")

(defvar *print-pretty* NIL
  "Indicates whether or not to nicely format expressions when printing them.")

(defvar *print-circle* NIL
  "If T, the printer will detect cycles in output expressions and print them
using the #n= and #n# syntax.")

(defvar *print-base* 10.
  "Determines what radix the printer will use to print rational numbers.")

(defvar *print-radix* NIL
  "If not NIL, the printer will print a radix specifier along with each
rational number.")

(defvar *print-case* :UPCASE
  "Controls the case of output.  :UPCASE means use upper case, :DOWNCASE means
use lower case, :CAPITALIZE means capitalize the first letter of each word.")

(defvar *print-gensym* T
  "Indicates whether or not to print #: in front of uninterned symbols.")

(defvar *print-level* NIL
  "Controls how many levels deep a nested object is printed.  If NIL, an
object is printed to arbitrary depth; if a number, parts of the object which
are nested more times than that number are printed as #.")

(defvar *print-length* NIL
  "Controls how many elements at a given level of nesting are printed.  If
NIL, all the elements on a given level are printed; if a number, then whenever
the number of objects on a level exceeds that number, the excess are printed
with three dots, ..., in their place.")

(defvar *print-array* NIL
  "If NIL, the contents of arrays (except for strings) are not printed.")

(defvar *print-nicely* NIL)


;;;----------------------------------------------------------------------------
;;; CYCLE TABLES
;;;----------------------------------------------------------------------------
;;;
;;; Duplications within a printed object's structure are kept track of in a
;;; cycle table.  A cycle table is generated by a top level print function, if
;;; *print-circle* is true, before the object is printed.  The cycle table is a
;;; hash table.  The table contains an entry whose key is :COUNTER and whose
;;; value is used to keep track of an index.  The index is used for #n= and #n#
;;; forms.  Other entries in the table keep track of duplicated objects.
;;;
;;; Each object which is part of the thing being printed is in one of four
;;; states:
;;;
;;;   NOT-CIRCULAR.  The object only occurs once in the thing being printed.
;;;   This state is represented by the object having no entry in the cycle
;;;   table, or having an entry of NIL in the cycle table.
;;;
;;;   NOT-PRINTED.  The object occurs more than once in the thing being
;;;   printed, but it has not yet been encountered by the printer.  Represented
;;;   by the object having a value of :NOT-PRINTED in the cycle table.
;;;
;;;   HEADER-PRINTED.  The object occurs more than once in the thing being
;;;   printed.  The #n= header has been printed for the object, but the object
;;;   itself has not yet been printed.  Represented by the object having a
;;;   value of (:HEADER-PRINTED n) in the cycle table.
;;;
;;;   PRINT-STARTED.  The object occurs more than once in the thing being
;;;   printed.  The #n= header has been printed for the object, and printing of
;;;   the object itself has commenced.  Represented by the object having a
;;;   value of (:PRINT-STARTED n) in the cycle table.
;;;
;;; The magic predicate PRINT-CIRCULAR-OBJECT returns true if an object should
;;; be printed, and NIL if it shouldn't.  This function also modifies the
;;; object's state in a cycle table and possibly prints a #n= or #n#
;;; expression.  Here's how it works:
;;;
;;;   If *print-circle* is nil, or the object's state is NOT-CIRCULAR, then
;;;   just return T.
;;;
;;;   If the object's state is NOT-PRINTED, generate an index n for the object,
;;;   print #n=, change the object's state to HEADER-PRINTED, and return T.
;;;
;;;   If the object's state is HEADER-PRINTED, return T.
;;;
;;;   If the object's state is PRINT-STARTED, print #n# and return NIL.
;;;
;;; It is the caller's responsibility to use the NOTE-PRINT-STARTED function,
;;; which changes an object's state to PRINT-STARTED.
;;;----------------------------------------------------------------------------

;;; This definition has been buggerred so that we can use the
;;; printer without hash tables in the cold-load.  For now we
;;; just return NIL.
(defun make-cycle-table ()
;  (make-hash-table :test 'EQ)
  NIL)

(defun find-cycles (thing)
  (let ((table (make-cycle-table)))
    (walk-object thing table)
    (puthash :COUNTER 1 table)
    table))

(defun walk-object (thing table)
  (flet ((add-entry (key)
           (let ((foo (gethash key table :not-present)))
             (cond
               ((eq foo :not-present)
                (puthash key NIL table)
                T)
               ((eq foo NIL)
                (puthash key :NOT-PRINTED table)
                NIL)
               (T
                NIL)))))
  (typecase thing
    (cons   (when (add-entry thing)
              (walk-object (car thing) table)
              (walk-object (cdr thing) table)))
    (vector (when (add-entry thing)
              (dotimes (i (length thing))
                (walk-object (aref thing i) table))))
    (array  (when (add-entry thing)
              (walk-object (array-to-list thing) table)))
    (symbol (unless (symbol-package thing)
              (add-entry thing))))))

(defun print-circular-object (thing table stream)
  "Print #n= or #n# if needed.  Return T if thing must be printed, NIL if it
doesn't have to."
  (if *print-circle*
      (let ((entry (gethash thing table))
            (count (gethash :COUNTER table)))
        (cond
          ((eq entry :NOT-PRINTED)
           (write-char #\# stream)
           (print-raw-fixnum count 10. stream)
           (write-char #\= stream)
           (puthash thing (list :HEADER-PRINTED count) table)
           (puthash :COUNTER (1+ count) table)
           T)
          ((eq (car entry) :HEADER-PRINTED)
           T)
          ((eq (car entry) :PRINT-STARTED)
           (write-char #\# stream)
           (print-raw-fixnum (second entry) 10. stream)
           (write-char #\# stream)
           NIL)
          (T
           T)))
      T))

(defun note-print-started (thing table)
  (when *print-circle*
    (let ((entry (gethash thing table)))
      (when (eq (first entry) :HEADER-PRINTED)
        (setf (first entry) :PRINT-STARTED)))))

;;; This definition has been buggerred so that we can use the
;;; printer without hash tables in the cold-load.  For now we
;;; just return NIL.
(defun circular-object-p (object table)
;  (gethash object table)
  NIL)


;;;----------------------------------------------------------------------------
;;; SPECIAL TOKENS
;;;----------------------------------------------------------------------------
;;;
;;; These aren't Common Lisp objects.  They are special tokens which print as
;;; the dot in a dotted list, ..., and #.
;;;----------------------------------------------------------------------------

(deftype sptoken ()
  '(satisfies special-token-p))

(defconstant *dot-token* 'THE-DOT-TOKEN)

(defconstant *three-dot-token* 'THE-THREE-DOT-TOKEN)

(defconstant *sharp-token* 'THE-SHARP-TOKEN)

(defconstant *special-tokens-list*
             (list *dot-token* *three-dot-token* *sharp-token*))

(defun special-token-p (thing)
  (member thing *special-tokens-list*))

(defun print-special (special-token stream)
  (write-string
    (cond ((eq special-token *dot-token*)       ".")
          ((eq special-token *three-dot-token*) "...")
          ((eq special-token *sharp-token*)     "#")
          (t (error "Unrecognized special token.")))
    stream))


;;;----------------------------------------------------------------------------
;;; CHARACTERS
;;;----------------------------------------------------------------------------

(defun print-character (char stream)
  (if *print-escape*
      (let ((basic-char (make-char char 0)))
        (write-char #\# stream)
        (write-char #\\ stream)
        (when (char-bit char :control) (write-string "Control-" stream))
        (when (char-bit char :meta)    (write-string "Meta-"    stream))
        (when (char-bit char :super)   (write-string "Super-"   stream))
        (when (char-bit char :hyper)   (write-string "Hyper-"   stream))
        (if (char-name basic-char)
            (write-string (string-capitalize (char-name basic-char)) stream)
            (progn
              (when (and (> (char-bits char) 0)
                         (must-escape-character-p basic-char))
                (write-char #\\ stream))
              (write-char basic-char stream))))
      (write-char char stream)))


;;;----------------------------------------------------------------------------
;;; SYMBOLS
;;;----------------------------------------------------------------------------

(defun print-symbol (symbol stream cycles)
  (let ((symbol-name (symbol-name symbol)))
    (when (or (symbol-package symbol)
              (print-circular-object symbol cycles stream))
      (if *print-escape*
          (progn
            (print-package-prefix symbol stream)
            (cond
              ((or (could-be-number symbol-name)
                   (must-escape-print-name-p symbol-name))
               (print-in-bars symbol-name stream))
              (t
               (print-symbol-print-name symbol-name stream))))
          (print-symbol-print-name symbol-name stream)))))

(defun print-package-prefix (symbol stream)
  (let ((current-package *package*)
        (symbol-package  (symbol-package symbol))
        (symbol-name     (symbol-name symbol)))
    (cond ((keywordp symbol)
           (write-string ":" stream))
          ((eq (intern symbol-name current-package) symbol)
           ())
          (symbol-package
           (write-string (package-name symbol-package) stream)
           (multiple-value-bind (ignore how-interned)
               (intern symbol-name symbol-package)
             (case how-interned
               (:INTERNAL (write-string "::" stream))
               (:EXTERNAL (write-string ":"  stream))
               (OTHERWISE (ferror "~S is not present in its home package."
                                  symbol)))))
          ((and *print-gensym* *print-escape*)
           (write-string "#:" stream)))))

(defun print-symbol-print-name (string stream)
  "Print STRING to STREAM, without escape characters, paying heed to nothing
but *print-case*."
  (case *print-case*
    (:UPCASE (write-string string stream))
    (:DOWNCASE (write-string (string-downcase string) stream))
    (:CAPITALIZE
     (do ((length (length string)) char prev-letter
          (i 0 (1+ i)))
         ((= i length))
       (setq char (char string i))
       (cond ((upper-case-p char)
              (write-char (if prev-letter (char-downcase char) char) stream)
              (setq prev-letter t))
             ((lower-case-p char)
              (write-char (if prev-letter char (char-upcase char)) stream)
              (setq prev-letter t))
             ((char<= #\0 char #\9)
              (write-char char stream)
              (setq prev-letter t))
             (t
              (write-char char stream)
              (setq prev-letter nil)))))))

(defun print-in-bars (string stream)
  "Print STRING to STREAM, engulfed in |'s, with \\'s and |'s within STRING
preceded by a \\."
  (write-char #\| stream)
  (do ((length (length string)) char
       (i 0 (1+ i)))
      ((= i length))
    (setq char (char string i))
    (when (or (char= char #\|)
              (char= char #\\))
      (write-char #\\ stream))
    (write-char char stream))
  (write-char #\| stream))

(defun could-be-number (string)
  (every #'(lambda (char)
             (digit-char-p char *print-base*))
         string))


;;;----------------------------------------------------------------------------
;;; FIXNA
;;;----------------------------------------------------------------------------

(defun print-raw-fixnum (number radix stream)
  (when (minusp number)
    (write-char #\- stream)
    (setq number (- number)))
  (multiple-value-bind (quotient remainder)
      (truncate number radix)
    (unless (zerop quotient)
      (print-raw-fixnum quotient radix stream))
    (write-char (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" remainder)
                stream)))

(defun print-print-radix-prefix (radix stream &optional print-10-p)
  (unless (<= 2. radix 36.)
    (error "~S is not a legal print radix." radix))
  (case radix
    (2.  (write-string "#b" stream))
    (8.  (write-string "#o" stream))
    (10. (when print-10-p (write-string "#10r" stream)))
    (16. (write-string "#x" stream))
    (t   (write-char #\# stream)
         (print-raw-fixnum radix 10. stream)
         (write-char #\r stream))))

(defun print-print-radix-suffix (radix stream)
  (when (= radix 10.)
    (write-char #\. stream)))

(defun print-fixnum (number stream)
  (let ((radix         *print-base*)
        (print-radix-p *print-radix*))
    (when print-radix-p
      (print-print-radix-prefix radix stream))
    (print-raw-fixnum number radix stream)
    (when print-radix-p
      (print-print-radix-suffix radix stream))))


;;;----------------------------------------------------------------------------
;;; RATIOS
;;;----------------------------------------------------------------------------

(defun print-ratio (ratio stream)
  (let ((radix         *print-base*)
        (print-radix-p *print-radix*))
    (when print-radix-p
      (print-print-radix-prefix radix stream t))
    (print-raw-fixnum (numerator ratio) radix stream)
    (write-char #\/ stream)
    (print-raw-fixnum (denominator ratio) radix stream)))


;;;----------------------------------------------------------------------------
;;; FLONUMS
;;;----------------------------------------------------------------------------

(defconstant *short-float-mantissa-bits* 17.)

(defconstant *single-float-mantissa-bits* 23.)

(defconstant *double-float-mantissa-bits* 52.)

(defconstant *long-float-mantissa-bits* 52.)

(defconstant *short-float-significant-digits*
             (floor (* (log 2 10) *short-float-mantissa-bits*)))

(defconstant *single-float-significant-digits*
             (floor (* (log 2 10) *single-float-mantissa-bits*)))

(defconstant *double-float-significant-digits*
             (floor (* (log 2 10) *double-float-mantissa-bits*)))

(defconstant *long-float-significant-digits*
             (floor (* (log 2 10) *long-float-mantissa-bits*)))

(defun significant-digits (flonum)
  (typecase flonum
    (short-float  *short-float-significant-digits*)
    (single-float *single-float-significant-digits*)
    (double-float *double-float-significant-digits*)
    (long-float   *long-float-significant-digits*)))

(defun exponent-character (flonum)
  (if (typep flonum *read-default-float-format*)
      #\e
      (typecase flonum
        (short-float  #\s)
        (single-float #\f)
        (double-float #\d)
        (long-float   #\L)
        (t
         (error "~S is not a flonum type." (type-of flonum))))))

(defun print-flonum (number stream &optional force-e-format)
  (when (minusp number)
    (write-char #\- stream)
    (setq number (- number)))
  (cond
    ((zerop number)
     (write-string "0.0" stream)
     (unless (typep number *read-default-float-format*)
       (write-char (exponent-character number) stream)
       (write-char #\0 stream)))
    ((or (< number 1.0s-3) (>= number 1.0s7) force-e-format)
     (multiple-value-bind (mantissa exponent)
         (scale-flonum number)
       (let ((digits-to-print (significant-digits number)))
         (setq mantissa
               (+ mantissa (* 5 (expt 0.1 digits-to-print))))
         (when (>= mantissa 10)
           (setq mantissa (/ mantissa 10))
           (setq exponent (1+ exponent)))
         (print-flonum-mantissa mantissa digits-to-print stream))
       (write-char (exponent-character number) stream)
       (print-raw-fixnum exponent 10. stream)))
    (t
     (let* ((digits-to-print       (significant-digits number))
            (digits-before-decimal (ceiling (log number 10)))
            (fraction-digits
              (max 0 (- digits-to-print digits-before-decimal))))
       (print-positive-flonum number stream fraction-digits))
     ;; ^^ This will lose in one case.  If there are more digits before the
     ;; decimal point than there are significant digits, some of the digits
     ;; printed will be meaningless.  Ex: A flonum that looks like 123456.8
     ;; but only having five significant digits.  (How should something like
     ;; this be printed, anyway?  Scheme says: 12346#.#)
     (unless (typep number *read-default-float-format*)
       (write-char (exponent-character number) stream)
       (write-char #\0 stream)))))

(defun scale-flonum (number)
  "Return the mantissa and exponent of a base-10 representation of NUMBER."
  (let* ((exponent (floor (log number 10)))
         (mantissa (/ number (expt 10 exponent))))
    (values mantissa exponent)))

(defun print-flonum-mantissa (mantissa digits-to-print stream)
  (let ((digit (floor mantissa)))
    (write-char (char "0123456789" digit) stream)
    (write-char #\. stream)
    (print-flonum-decimals (- mantissa digit) stream (1- digits-to-print))))

(defun print-positive-flonum (number stream fraction-digits)
  (setq number (+ number (* 0.5 (expt 0.1 fraction-digits))))
  (multiple-value-bind (integer-part fraction-part)
      (floor number)
    (print-raw-fixnum integer-part 10. stream)
    (write-char #\. stream)
    (print-flonum-decimals fraction-part stream fraction-digits)))

(defun print-flonum-decimals (number stream digits-to-print
                              &key print-trailing-zeros
                                   no-digits-for-zero)
  "NUMBER must satisfy 0 <= NUMBER < 1.  Print DIGITS-TO-PRINT decimal digits
of NUMBER onto STREAM.  If PRINT-TRAILING-ZEROS is true, then print trailing
zeros; otherwise suppress them.  If NO-DIGITS-FOR-ZERO is false, then always
print at least one digit, even if it's zero."
  (let ((string (make-string digits-to-print))
        (index  0))
    (labels ((do-digits (number)
               (unless (>= index digits-to-print)
                 (let* ((number*10 (* number 10))
                        (digit     (floor number*10)))
                   (setf (char string index) (char "0123456789" digit))
                   (incf index)
                   (do-digits (- number*10 digit)))))
             (remove-trailing-zeros ()
               (when (and (> index 0)
                          (char= (char string (1- index)) #\0))
                 (decf index)
                 (remove-trailing-zeros))))
      (do-digits number)
      (unless print-trailing-zeros (remove-trailing-zeros))
      (write-string string stream :end index)
      (when (and (= index 0) (not no-digits-for-zero))
        (write-char #\0 stream)))))


;;; Bigna code narfed from Lambda sources.

;;; Printing bigna
;(defun print-bignum-piece (piece radix stream ndigits)
;  (when (or (> ndigits 1) (>= piece radix))
;    (print-bignum-piece (truncate piece radix) radix stream (1- ndigits)))
;  (write-char (char "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" (rem piece radix)) stream))

;;; Print the digits of a bignum
;(defun print-raw-bignum (num radix stream &aux length max-radix digits-per-q)
;  (setq digits-per-q (floor %%q-pointer (haulong radix))
;       max-radix (^ radix digits-per-q)
;       num (bignum-to-array num max-radix)
;       length (array-length num))
;  (do ((index (1- length) (1- index))
;       (ndigits -1 digits-per-q))
;      ((minusp index))
;    (print-bignum-piece (aref num index) radix stream ndigits)))

;(defprinter print-bignum bignum (bignum stream &aux (base (current-print-base)))
;  (declare (unspecial base))
;  (when *print-radix*
;    (print-print-radix-prefix base stream))
;  (when (minusp bignum)
;    (write-char (pttbl-minus-sign (rdtbl-print-table *readtable*)) stream))
;  (if (fixnump base)
;      (print-raw-bignum bignum base stream)
;    (funcall (get base 'princ-function) (- bignum) stream))
;  (when (and (or *print-radix* (not *nopoint))
;            (eq base 10.))
;    (write-char #\. stream))
;  bignum)


;;;----------------------------------------------------------------------------
;;; COMPLEX
;;;----------------------------------------------------------------------------

(defun print-complex (number stream cycles)
  (write-string "#C(" stream)
  (print-object (realpart number) stream cycles)
  (write-string " " stream)
  (print-object (imagpart number) stream cycles)
  (write-string ")" stream))


;;;----------------------------------------------------------------------------
;;; CONSES
;;;----------------------------------------------------------------------------

(defun list-length-equals-p (list length)
  (let ((len (list-length list)))
    (and len (= len length) (null (nthcdr len list)))))


(defun print-cons (cons stream cycle-table)
  (when (print-circular-object cons cycle-table stream)
    (cond
      ((and *print-level* (zerop *print-level*))
       (write-string "#" stream))
      ((and (or *print-pretty* *print-nicely*)
            (list-length-equals-p cons 2)
            (member (first cons)
                    '(QUOTE FUNCTION BACKQUOTE UNQUOTE UNQUOTE-SPLICING
                      DESTRUCTIVE-UNQUOTE-SPLICING SI::DISPLACED)))
       (note-print-started cons cycle-table)
       (case (first cons)
         (QUOTE                        (write-char #\' stream))
         (FUNCTION                     (write-string "#'" stream))
         (BACKQUOTE                    (write-char #\` stream))
         (UNQUOTE                      (write-char #\, stream))
         (UNQUOTE-SPLICING             (write-string ",@" stream))
         (DESTRUCTIVE-UNQUOTE-SPLICING (write-string ",." stream))
         (SI::DISPLACED                NIL))
       (print-object (second cons) stream cycle-table))
      (*print-pretty*
       (grind-list cons (get-indentation (first cons)) stream cycle-table))
      (t
       (note-print-started cons cycle-table)
       (write-char #\( stream)
       (print-list-elements cons stream cycle-table)
       (write-char #\) stream)))))

(defun print-list-elements (list stream cycle-table)
  (do ((current-cons-cell list (cdr current-cons-cell))
       (number-printed    0    (1+ number-printed)))
      (nil)
    (let ((current-car (car current-cons-cell))
          (current-cdr (cdr current-cons-cell)))
      (cond
        ((null current-cons-cell)
         (return))
        ((and *print-length* (>= number-printed *print-length*))
         (write-string "..." stream)
         (return))
        (t
         (let ((*print-level* (decrement *print-level*)))
           (print-object current-car stream cycle-table))
         (cond
           ((and (consp current-cdr)
                 (not (circular-object-p current-cdr cycle-table)))
            (write-string " " stream))
           ((not (null current-cdr))
            (write-string " . " stream)
            (let ((*print-level* (decrement *print-level*)))
              (print-object current-cdr stream cycle-table))
            (return))
           (t
            (return))))))))

(defun decrement (frob)
  "If FROB is not NIL, return FROB - 1.  Otherwise, return NIL."
  (if frob (1- frob) NIL))


;;;----------------------------------------------------------------------------
;;; STRINGS
;;;----------------------------------------------------------------------------

(defun print-string (string stream)
  (if *print-escape*
      (progn
        (write-char #\" stream)
        (dotimes (i (length string))
          (print-string-char (char string i) stream))
        (write-char #\" stream))
      (dotimes (i (length string))
        (write-char (char string i) stream))))

(defun print-string-char (char stream)
  (when (or (char= char #\\)
            (char= char #\"))
    (write-char #\\ stream))
  (write-char char stream))


;;;----------------------------------------------------------------------------
;;; BIT VECTORS
;;;----------------------------------------------------------------------------

(defun print-bit-vector (bit-vector stream)
  (cond
    ((not *print-array*)
     (write-string "#<Bit Vector>" stream))
    (t
     (write-string "#*" stream)
     (dotimes (i (length bit-vector))
       (print-bit-char (bit bit-vector i) stream)))))

(defun print-bit-char (bit stream)
  (if (zerop bit)
      (write-char #\0 stream)
      (write-char #\1 stream)))


;;;----------------------------------------------------------------------------
;;; VECTORS
;;;----------------------------------------------------------------------------

(defun print-vector (vector stream cycles)
  (cond
    ((not *print-array*)
     (write-string "#<Vector>" stream))
    ((and *print-level* (zerop *print-level*))
     (write-string "#" stream))
    (*print-pretty*
     (grind-vector vector stream cycles))
    ((print-circular-object vector cycles stream)
     (write-char #\# stream)
     (print-array-contents vector NIL stream cycles))))


;;;----------------------------------------------------------------------------
;;; ARRAYS
;;;----------------------------------------------------------------------------

(defun print-array (array stream cycles)
  (cond
    ((not *print-array*)
     (write-string
       (format nil "#<Array ~{~S~^x~}>" (array-dimensions array))
       stream))
    ((and *print-level* (zerop *print-level*))
     (write-string "#" stream))
    (*print-pretty*
     (grind-array array stream cycles))
    ((print-circular-object array cycles stream)
     (write-char #\# stream)
     (print-raw-fixnum (array-rank array) 10. stream)
     (write-char #\A stream)
     (print-array-contents array NIL stream cycles))))

(defun print-array-contents (array indices stream cycles)
  (print-object (array-to-list array :indices indices) stream cycles))

(defun array-to-list (array &key indices stringify)
  "Return a list representation of the subarray of ARRAY specified by INDICES.
If INDICES is NIL, return a list representation of the entire array.  If
STRINGIFY is not nil, then arrays of characters will be considered strings and
arrays of bits will be considered bit-vectors."
  (let* ((next-dimension     (length indices))
         (rank-of-subarray   (- (array-rank array) (length indices))))
    (if (zerop rank-of-subarray)
        (apply #'aref array indices)
        (let ((length-of-subarray (array-dimension array next-dimension))
              (result NIL))
          (dotimes (i length-of-subarray)
            (push (array-to-list array :indices (append indices (list i))
                                 :stringify stringify)
                  result))
          (setq result (nreverse result))
          (cond
            ((every #'characterp result)
             (coerce result 'string))
            ((every #'bit-vector-p result)
             (coerce result 'bit-vector))
            (t
             result))))))

;(defun print-array-contents (array indices stream cycles)
;  (let* ((rank-of-subarray       (- (array-rank array) (length indices)))
;        (next-dimension         (length indices))
;        (length-of-subarray     (array-dimension array next-dimension))
;        (subarray-is-string     NIL)
;        (subarray-is-bit-vector NIL))
;    (when (and (= rank-of-subarray 1)
;              (or (not *print-length*) (>= length-of-subarray *print-length*)))
;      (cond ((typep array `(array bit ,(array-rank array)))
;            (setq subarray-is-bit-vector T))
;           ((typep array `(array character ,(array-rank array)))
;            (setq subarray-is-string T))))
;    (cond (subarray-is-string     (write-char #\" stream))
;         (subarray-is-bit-vector (write-string "#*" stream))
;         (t                      (write-char #\( stream)))
;    (dotimes (i length-of-subarray)
;      (cond ((and *print-length* (>= i *print-length*))
;            (write-string "..." stream)
;            (return))
;           ((> rank-of-subarray 1)
;            (print-array-contents array (append indices (list i))
;                                  stream cycles))
;           (subarray-is-string
;            (print-string-char (apply #'aref array (append indices (list i)))
;                               stream))
;           (subarray-is-bit-vector
;            (print-bit-char (apply #'aref array (append indices (list i)))
;                            stream))
;           (t
;            (let ((*print-level* (decrement *print-level*)))
;              (print-object (apply #'aref array (append indices (list i)))
;                            stream cycles))))
;      (unless (or (= (1+ i) length-of-subarray)
;                 subarray-is-string
;                 subarray-is-bit-vector)
;       (write-string " " stream)))
;    (write-char #\) stream)))


;;;----------------------------------------------------------------------------
;;; DISPATCH
;;;----------------------------------------------------------------------------

(defun print-object (thing stream cycle-table)
  (typecase thing
    (sptoken    (print-special    thing stream))
    (character  (print-character  thing stream))
    (symbol     (print-symbol     thing stream cycle-table))
    (string     (print-string     thing stream))
    (integer    (print-fixnum     thing stream))
    (ratio      (print-ratio      thing stream))
    (float      (print-flonum     thing stream))
    (complex    (print-complex    thing stream cycle-table))
    (bit-vector (print-bit-vector thing stream))
    (cons       (print-cons       thing stream cycle-table))
    (vector     (print-vector     thing stream cycle-table))
    (array      (print-array      thing stream cycle-table))
    (t
     (error "I don't know how to print objects of type ~S."
            (type-of thing)))
    )
  thing)


;;;----------------------------------------------------------------------------
;;; PUBLIC FUNCTIONS
;;;----------------------------------------------------------------------------

(defun write (object &key (stream *standard-output*)
                          (escape *print-escape*)
                          (radix  *print-radix*)
                          (base   *print-base*)
                          (circle *print-circle*)
                          (pretty *print-pretty*)
                          (level  *print-level*)
                          (length *print-length*)
                          (case   *print-case*)
                          (gensym *print-gensym*)
                          (array  *print-array*))
  "Print OBJECT on STREAM, which defaults to *STANDARD-OUTPUT*.  The keyword
arguments control multiferous printing formats.  Return OBJECT."
  (when (eq stream t)
    (setq stream *terminal-io*))
  (let ((*standard-output* stream)
        (*print-escape* escape)
        (*print-radix*  radix)
        (*print-base*   base)
        (*print-circle* circle)
        (*print-pretty* pretty)
        (*print-level*  level)
        (*print-length* length)
        (*print-case*   case)
        (*print-gensym* gensym)
        (*print-array*  array))
    (print-object
      object
      (if *print-pretty*
          (make-grinder 50. stream)
          stream)
      (if *print-circle*
          (find-cycles object)
          (make-cycle-table))))
  object)

(defun prin1 (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, using escape characters.  Return OBJECT."
  (when (eq stream t)
    (setq stream *terminal-io*))
  (write object :stream stream :escape t))

(defun print (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, using escape characters, with a newline before and
a space after.  Return OBJECT."
  (when (eq stream t)
    (setq stream *terminal-io*))
  (terpri)
  (write object :stream stream :escape t)
  (write-char #\Space stream)
  object)

(defun pprint (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, formatted nicely, preceded by a newline.  Return
zero values."
  (when (eq stream t)
    (setq stream *terminal-io*))
  (terpri)
  (write object :stream stream :pretty t)
  (values))

(defun princ (object &optional (stream *standard-output*))
  "Write OBJECT onto STREAM, without any escape characters.  Return OBJECT."
  (when (eq stream t)
    (setq stream *terminal-io*))
  (write object :stream stream :escape nil))

(defun write-to-string (object &key (escape *print-escape*)
                                    (radix  *print-radix*)
                                    (base   *print-base*)
                                    (circle *print-circle*)
                                    (pretty *print-pretty*)
                                    (level  *print-level*)
                                    (length *print-length*)
                                    (case   *print-case*)
                                    (gensym *print-gensym*)
                                    (array  *print-array*))
  "Write OBJECT to a string.  The keyword arguments control multiferous format
parameters."
  (let ((*print-escape* escape)
        (*print-radix*  radix)
        (*print-base*   base)
        (*print-circle* circle)
        (*print-pretty* pretty)
        (*print-level*  level)
        (*print-length* length)
        (*print-case*   case)
        (*print-gensym* gensym)
        (*print-array*  array))
    (let ((stream      (if *print-pretty*
                           (make-grinder 50. (make-string-output-stream))
                           (make-string-output-stream)))
          (cycle-table (if *print-circle*
                           (find-cycles object)
                           (make-cycle-table))))
      (print-object object stream cycle-table)
      (get-output-stream-string stream))))

(defun prin1-to-string (object)
  "Return a string, the printed representation of OBJECT, with escape
characters if necessary."
  (write-to-string object :escape t))

(defun princ-to-string (object)
  "Return a string, the printed representation of OBJECT, without escape
characters."
  (write-to-string object :escape nil))
